home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Boot / threads.em < prev    next >
Encoding:
Text File  |  1993-06-29  |  2.8 KB  |  108 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: threads.em
  4. ;; Date: Mon Jun 28 17:18:22 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  Higher level thread operations.
  9. ;;  Mostly deal with signals, initialization and printing
  10.  
  11. (defmodule threads
  12.   (defs
  13.    init
  14.    list-fns
  15.    (rename ((open-primitive-semaphore lock)
  16.         (close-primitive-semaphore unlock))
  17.        semaphores)
  18.    )
  19.   ()
  20.   
  21.   (export <thread> threadp thread-reschedule current-thread thread-start
  22.       thread-value <thread-condition> <wrong-thread-continue>)
  23.   
  24.   (defclass <thread-condition> (<condition>)
  25.     ()
  26.     )
  27.  
  28.   (defun open-semaphore-with-signals (isem)
  29.     (or (lock isem)
  30.     (progn (handle-pending-signals)
  31.            (open-semaphore-with-signals isem))))
  32.  
  33.   (defun thread-reschedule ()
  34.     (sys-thread-reschedule)
  35.     (handle-pending-signals))
  36.   
  37.   (defun thread-value (thread)
  38.     (let ((res (sys-thread-value thread)))
  39.       (if (cdr res) (car res)
  40.     (progn (handle-pending-signals)
  41.            (thread-value thread)))))
  42.   
  43.   (defun thread-suspend ()
  44.     (sys-thread-suspend)
  45.     (handle-pending-signals))
  46.  
  47.   ;; NB: it is impossible to raise a non-continuable error on a thread...
  48.   (defun thread-signal (cond fn thread)
  49.     (let ((sem (car (thread-signals thread))))
  50.       (lock sem)
  51.       ((setter thread-signals) thread 
  52.        (nconc (thread-signals thread) (cons cond fn)))
  53.       (unlock sem))
  54.     (if (eq (current-thread) thread)
  55.     (handle-pending-signals)
  56.       nil))
  57.  
  58.   (defun handle-pending-signals ()
  59.     (let ((thread-signals (thread-signals (current-thread))))
  60.       (lock (car thread-signals))
  61.       (let ((lst (copy-list (cdr thread-signals))))
  62.     ((setter cdr) thread-signals nil)
  63.     (unlock (car thread-signals))
  64.     (mapcar (lambda (cond)
  65.           (let/cc next 
  66.               (internal-signal (car cond) next)))
  67.         lst)
  68.     nil)))
  69.   
  70.   (defconstant sig-table (make-table)
  71.  
  72.   (defun internal-thread-signal (thread flags)
  73.     (do (lambda (key elt) 
  74.       (if elt (thread-signal thread nil
  75.                  (make (table-ref sig-table)))
  76.         nil))
  77.     (convert flags bit-vector)))
  78.  
  79.   ((setter signal-handler) thread-signal)
  80.   
  81.   ;; Thread Junk. Doesn't belong, but nowhere better for it..
  82.   (defmethod allocate ((x <thread-class>) lst)
  83.     (generic_allocate_instance\,Thread_Class x lst))
  84.  
  85.   (defmethod initialize ((x <thread>) lst)
  86.     (let ((new (call-next-method)))
  87.       (initialize-thread new lst)
  88.       ((setter  thread-signals) new 
  89.        (cons (make-primitive-semaphore) nil))
  90.       new))
  91.   
  92.   (add-method generic-prin 
  93.           (make <method>
  94.             'signature (list <thread> <object>)
  95.             'function (method-lambda (thread s)
  96.                          (let ((state (thread-state thread)))
  97.                            (format s "#<~a: ~u ~a ~a>"
  98.                                (class-name (class-of thread))
  99.                                thread state
  100.                                (if (eq state 'returned)
  101.                                (thread-value thread) 
  102.                              "{undetermined}"))))))
  103.   
  104.   
  105.  
  106.   ;; end module
  107.   )
  108.